home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / COMAL / B-Book Series / (k)b9.d64 / src.example < prev    next >
Text File  |  2007-02-28  |  7KB  |  401 lines
  1. ;
  2. ;EXAMPLE PACKAGES FOR COMAL 2.0
  3. ;
  4. ;BY JESSE KNIGHT
  5. ;
  6. ;ADD + STRING$ FROM UNICOMAL (WITH CHANGES)
  7. ;
  8. ; 1/29/85
  9. ;
  10.  .LIB C64SYMB
  11.  .OPT LIST
  12. ;
  13.  *=$8009
  14. ;
  15. ;
  16. ;
  17.  .BYT DEFPAG ;MEMORY MAP
  18.  .WOR END ;END OF PACKAGE
  19.  .WOR SENSE ;SENSE ROUTINE
  20. ;
  21. ;TABLE OF PACKAGES
  22. ;
  23.  .BYT 4,'DEMO'   ;NAME IS DEMO
  24.  .WOR DEMOP ;DEMO PROCEDURE TABLE
  25.  .WOR DEMOI ;DEMO INIT ROUTINE
  26. ;
  27.  .BYT 6,'LOCATE' ;NAME IS LOCATE
  28.  .WOR LOCP ;LOCATE PROCEDURE TABLE
  29.  .WOR LOCI ;LOCATE INIT ROUTINE
  30. ;
  31.  .BYT 0 ;END OF TABLE
  32. ;
  33. ;SET BORDER COLOR TO FLAG
  34. ;SENT TO SENSE ROUTINE
  35. ;FOR VISIBLE EFFECT
  36. ;
  37. SENSE STY BORCOL
  38.  RTS
  39. ;
  40. ;FLASH BORDER COLOR
  41. ;IN DEMO INIT ROUTINE FOR
  42. ;VISIBLE EFFECT
  43. ;
  44. DEMOI LDX #16 ;16 TIMES
  45.  LDY #0 ;256 TIMES
  46. FLASH INC BORCOL
  47.  DEX
  48.  BNE FLASH
  49.  DEY
  50.  BNE FLASH
  51.  RTS
  52. ;
  53. ;PROCEDURE TABLE FOR DEMO
  54. ;
  55. DEMOP .BYT 3,'ADD' ;FUNCTION ADD
  56.  .WOR FADD ;DESCRIPTOR POINTER
  57.  .BYT 6,'STRING'   ;FUNCTION STRING
  58.  .WOR FSTRNG
  59.  .BYT 12,'CONVERT''CASE' ;PROC CONVERT'CASE
  60.  .WOR PCASE
  61.  .BYT 0 ;END OF TABLE
  62. ;
  63. ;FUNC ADD#(A#,B#)
  64. ;
  65. FADD .BYT FUNC+INT ;INTEGER FUNC
  66.  .WOR ADD ;POINT TO CODE
  67.  .BYT 2 ;2 PARAMETERS
  68.  .BYT PARAM+INT,PARAM+INT ;BOTH INTEGER
  69.  .BYT ENDFNC ;END FUNC
  70. ;
  71. ;FUNC STRING$(A$,N)
  72. ;
  73. FSTRNG .BYT FUNC+STR ;STRING FUNC
  74.  .WOR STRING ;POINT TO CODE
  75.  .BYT 2 ;2 PARAMETERS
  76.  .BYT PARAM+STR ;FIRST IS STRING
  77.  .BYT PARAM+INT ;SECOND IS INTEGER
  78.  .BYT ENDFNC ;END FUNC
  79. ;
  80. ;PROC CONVERT'CASE(REF A$,B)
  81. ;
  82. PCASE .BYT PROC ;PROCEDURE
  83.  .WOR CVCASE ;POINT TO CODE
  84.  .BYT 2 ;2 PARAMETERS
  85.  .BYT REF+STR ;FIRST IS REF STRING
  86.  .BYT PARAM+INT ;SECOND IS INTEGER
  87.  .BYT ENDPRC ;END PROC
  88. ;
  89. ;
  90. ;FUNC ADD#(A#,B#)
  91. ; RETURN A#+B#
  92. ;ENDFUNC ADD#
  93. ;
  94. ADD LDA #1
  95.  JSR FNDPAR ;FIND PARAM 1
  96. ;
  97.  LDX COPY1 ;MOVE COPY1 TO COPY2
  98.  STX COPY2
  99.  LDX COPY1+1
  100.  STX COPY2+1
  101. ;
  102.  LDA #2
  103.  JSR FNDPAR ;FIND PARAM 2
  104. ;
  105.  LDY #1 ;GET READY TO ADD
  106.  CLC
  107.  LDA (COPY1),Y ;ADD LO BYTES
  108.  ADC (COPY2),Y
  109.  TAX ;SAVE IN .X
  110.  DEY
  111.  LDA (COPY1),Y ;ADD HI BYTES
  112.  ADC (COPY2),Y
  113.  BVS OVRERR ;OVERFLOW ERROR
  114. ;
  115.  JMP PSHINT ; INT IN .A/.X TO REAL, PUSH, AND RETURN
  116. ;
  117. OVRERR LDX #2 ; REPORT "OVERFLOW"
  118.  JMP RUNERR
  119. ;
  120. ;FUNC STRING$(A$,N#)
  121. ; IF N#<0 THEN REPORT 1 //ARGUMENT ERROR
  122. ; IF LEN(A$)<>1 THEN REPORT 1,"STRING LENGTH ..."
  123. ; DIM R$ OF N#
  124. ; FOR X#=1 TO N# DO
  125. ;  R$:+A$
  126. ; ENDFOR X#
  127. ; RETURN R$
  128. ;ENDFUNC STRING$
  129. ;
  130. STRING LDA #2
  131.  JSR FNDPAR ;FIND PARAM 2
  132.  LDY #0
  133.  LDA (COPY1),Y ;HI BYTE
  134.  BMI ARGERR ;NEGATIVE
  135.  STA NUMBER+1 ;SAVE IT
  136.  INY
  137.  LDA (COPY1),Y ;LO BYTE
  138.  STA NUMBER ;SAVE IT
  139. ;
  140. ;MAKE ROOM FOR RESULT ON EVALUATION STACK
  141. ;REPORT "CANNOT ASSIGN VARIABLE" IF NO ROOM
  142. ;
  143.  CLC
  144.  ADC STOS ;TOP OF STACK
  145.  TAX ;SAVE IN .X
  146.  LDA NUMBER+1 ;HI BYTE
  147.  ADC STOS+1
  148.  BCS STERR ;OUT OF MEMORY ERROR
  149.  TAY ;SAVE IN .X
  150.  TXA
  151.  ADC #2 ;2 BYTES FOR LENGTH
  152.  TAX
  153.  TYA
  154.  ADC #0 ;ADD CARRY
  155.  BCS STERR ;ERROR
  156. ;
  157.  CPX SFREE ;TEST IF ROOM
  158.  SBC SFREE+1
  159.  BCS STERR ;NOT ENOUGH ROOM
  160. ;
  161. ;TEST A$
  162. ;
  163.  LDA #1
  164.  JSR FNDPAR ;FIND IT
  165.  LDY #2 ;TEST CURRENT LENGTH
  166.  LDA (COPY1),Y ;HI BYTE
  167.  BNE LNGERR ;>=256 - LONG STRING ERROR
  168.  INY
  169.  LDA (COPY1),Y ;LO BYTE
  170.  CMP #1
  171.  BNE LNGERR ;NOT =1 -LONG STRING ERROR
  172. ;
  173.  INY ;.Y=4
  174.  LDA (COPY1),Y ;CONTENTS OF A$
  175.  LDY #0
  176.  STY Q1 ;Q1=0
  177.  STY Q1+1
  178. ;
  179. STR1 LDX NUMBER+1 ;TEST FOR END OF LOOP
  180.  CPX Q1+1
  181.  BNE STR2 ;NOT YET
  182.  LDX NUMBER
  183.  CPX Q1
  184.  BEQ STR4 ;END OF LOOP
  185. ;
  186. STR2 STA (STOS),Y ;PUT ON STACK
  187.  INC STOS ;INC POINTER
  188.  BNE STR3
  189.  INC STOS+1
  190. ;
  191. STR3 INC Q1
  192.  BNE STR1 ;MORE TO DO
  193.  INC Q1+1
  194.  BNE STR1 ;(JMP)
  195. ;
  196. STR4 LDA NUMBER+1 ;PUT LENGTH ON STACK
  197.  STA (STOS),Y ;HI BYTE
  198.  INY
  199.  LDA NUMBER
  200.  STA (STOS),Y
  201. ;
  202.  CLC ;STOS:+2 FOR LENGTH
  203.  LDA STOS
  204.  ADC #2
  205.  STA STOS
  206.  BCC STR5
  207.  INC STOS+1
  208. STR5 RTS ;IT'S DONE
  209. ;
  210. ARGERR LDX #1 ;ARGUMENT ERROR
  211.  .BYT $2C ;SKIP 2
  212. STERR LDX #56 ;CANNOT ASSIGN VARIABLE
  213.  JMP RUNERR
  214. ;
  215. ;SPECIAL ERROR REPORTER FOR STRING$
  216. ;
  217. ;REPORTS ERROR NUMBER 1 FOR ARGUMENT ERROR
  218. ;BUT GIVES MORE SPECIFIC MESSAGE
  219. ;"STRING LENGTH OF 1 EXPECTED"
  220. ;
  221. ;ERRFILE IS SET TO 0 SINCE ERROR NOT FROM FILE
  222. ;
  223. ;ERROR NUMBER MUST BE IN RANGE 0 .. 65535
  224. ;
  225. ;TEXT FOR ERROR MUST BE <80 CHARACTERS
  226. ;
  227. LNGERR LDY #TXTLEN ;LENGTH OF TEXT
  228.  STY ERTLEN ;SET LENGTH FOR SYSTEM
  229. XFRTXT LDA ERRMSG-1,Y ;MOVE TEXT TO ERTEXT
  230.  STA ERTEXT-1,Y
  231.  DEY
  232.  BNE XFRTXT
  233. ;
  234.  LDA #$6C ;STORE JMP (TRAPVC) IN AC1
  235.  LDX #<TRAPVC
  236.  LDY #>TRAPVC
  237.  STA AC1
  238.  STX AC1+1
  239.  STY AC1+2
  240. ;
  241.  LDY #0 ;ERRFILE = 0
  242.  LDX #1 ;LO BYTE OF ERR #
  243.  LDA #0 ;HI BYTE OF ERR #
  244. ;
  245. ;NOW EXECUTE JMP (TRAPCV) IN PAGE B
  246. ;
  247.  JSR GOTO ;USING GOTO
  248.  .BYT PAGEB ;PAGE B
  249.  .WOR AC1 ;JMP (TRAPVC) AT AC1
  250. ;
  251. ;TEXT FOR ERROR MESSAGE
  252. ;
  253. ERRMSG .BYT 'STRING LENGTH OF 1 EXPECTED'
  254. TXTLEN =*-ERRMSG
  255. ;
  256. ;
  257. ;PROC CONVERT'CASE (REF A$,B)
  258. ; IF B<0 OR B>1 THEN REPORT 2 //ARGUMENT ERROR
  259. ; IF LEN(A$)>0 THEN  // NOT NULL STRING
  260. ;  IF B=0 THEN  //LOWER TO UPPER
  261. ;   C=65 //LOWER BOUND
  262. ;   D=91 //UPPER BOUND
  263. ;  ENDIF
  264. ;
  265. ;  IF B=1 THEN  //UPPER TO LOWER
  266. ;   C=193 //LOWER BOUND
  267. ;   D=219 //UPPER BOUND
  268. ;  ENDIF
  269. ;
  270. ;  FOR X=1 TO LEN(A$)
  271. ;   IF ORD(A$(X))>=C AND ORD(A$(X))<D  THEN //WRAP LINE
  272. ;   A$(X)=CHR$(ORD(A$(X))BITXOR($80)) //FLIP CASE
  273. ;  ENDFOR X
  274. ; ENDIF
  275. ;
  276. ;ENDPROC CONVERT'CASE
  277. ;
  278. CVCASE LDA #2 ;FIND B
  279.  JSR FNDPAR
  280.  LDY #0 ;TEST B
  281.  LDA (COPY1),Y ;HI BYTE
  282.  BMI ARGERR ;<0
  283.  INY
  284.  LDA (COPY1),Y ;LO BYTE
  285.  CMP #2
  286.  BCS ARGERR ;>1
  287. ;
  288.  CMP #1 ;WHICH WAY ?
  289.  BEQ LWER ;UPPER TO LOWER
  290. ;
  291.  LDA #65 ;SET BOUNDS FOR LOWER TO UPPER
  292.  STA LOWBND
  293.  LDA #91
  294.  STA UPRBND
  295.  BNE CVC ;(JMP)
  296. ;
  297. LWER LDA #193 ;SET BOUNDS FOR UPPER TO LOWER
  298.  STA LOWBND
  299.  LDA #219
  300.  STA UPRBND
  301. ;
  302. ;
  303. CVC LDA #1 ;FIND A$
  304.  JSR FNDPAR
  305.  LDY #2 ;GET LENGTH
  306.  LDA (COPY1),Y ;HI BYTE
  307.  TAX ;SAVE IN .X
  308.  INY
  309.  LDA (COPY1),Y ;LO BYTE
  310.  STA INF1 ;SAVE IN INF1
  311. ;
  312.  BNE NTNULL ; LO>0
  313.  TXA
  314.  BNE NTNULL ; LO AND HI =0
  315.  RTS ;NULL STRING NO ACTION
  316. ;
  317. NTNULL INY
  318. CVC1 LDA (COPY1),Y ;BYTE OF STRING
  319.  CMP LOWBND ;TEST LOWER BOUND
  320.  BCC OUTBND ;< BOUND
  321.  CMP UPRBND ;TEST UPPER BOUND
  322.  BCS OUTBND ;>= BOUND
  323. ;
  324.  EOR #$80 ;TOGGLE CASE         
  325.  STA (COPY1),Y ;STORE NEW VALUE
  326. ;
  327. OUTBND DEC INF1 ;DEC LO COUNTER
  328.  BNE NTDNE ;NOT DONE YET
  329.  DEX ;DEC HI COUNTER
  330.  BPL NTDNE ;NOT DONE YET
  331.  RTS ;FINISHED
  332. ;
  333. NTDNE INY ;NEXT CHAR
  334.  BNE CVC1 ;MORE TO DO
  335.  INC COPY1+1 ;BUMP HI
  336.  JMP CVC1
  337. ;
  338. LOWBND .BYT 0 ;LOWER BOUND STORAGE
  339. UPRBND .BYT 0 ;UPPER BOUND STORAGE
  340. ;
  341. ;PACKAGE: LOCATE
  342. ;
  343. LOCI RTS ;NO INIT NEEDED FOR LOCATE
  344. ;
  345. ;PROCEDURE TABLE FOR LOCATE
  346. ;
  347. LOCP .BYT 11,'LOCATE''REAL' ;FUNCTION LOCATE'REAL
  348.  .WOR FLOCRL ;DESCRIPTOR POINTER
  349.  .BYT 10,'LOCATE''INT' ;FUNCTION LOCATE'INT
  350.  .WOR FLOCIN
  351.  .BYT 10,'LOCATE''STR' ;FUNC LOCATE'STR
  352.  .WOR FLOCST
  353.  .BYT 0 ;END OF TABLE
  354. ;
  355. ;FUNC LOCATE'REAL (REF A)
  356. ;
  357. FLOCRL .BYT FUNC+REAL ;REAL FUNC
  358.  .WOR LOCCOD ;POINT TO CODE
  359.  .BYT 1 ;1 PARAMETER
  360.  .BYT REF+REAL ;REFERENCE REAL
  361.  .BYT ENDFNC
  362. ;
  363. ;FUNC LOCATE'INT (REF A#)
  364. ;
  365. FLOCIN .BYT FUNC+REAL ;REAL FUNC
  366.  .WOR LOCCOD ;POINT TO CODE
  367.  .BYT 1 ;1 PARAMETER
  368.  .BYT REF+INT ;REFERENCE INTEGER
  369.  .BYT ENDFNC
  370. ;
  371. ;FUNC LOCATE'STR (REF A$)
  372. ;
  373. FLOCST .BYT FUNC+REAL ;REAL FUNC
  374.  .WOR LOCCOD ;POINT TO CODE
  375.  .BYT 1 ;1 PARAMETER
  376.  .BYT REF+STR ;REFERENCE STRING
  377.  .BYT ENDFNC
  378. ;
  379. ;ALL FUNCTIONS IN LOCATE ARE
  380. ;TO RETURN THE ADDRESS OF THE VARIABLE
  381. ;PASSED AS THE PARAMETER.
  382. ;
  383. ;DIFFERENT FUNCTIONS ARE NEEDED
  384. ;FOR EACH VARIABLE TYPE BECAUSE
  385. ;OF THE PARAMETER TYPE TESTS
  386. ;PERFORMED BY COMAL.
  387. ;
  388. ;SEPERATE CODE IS NOT NEEDED TO
  389. ;RETURN THE ADDRESS SINCE FINDING
  390. ;THE PARAMETER AND RETURNING ITS
  391. ;ADDRESS IS THE SAME FOR ALL TYPES.
  392. ;
  393. LOCCOD LDA #1 ;FIRST PARAM
  394.  JSR FNDPAR ;FIND IT
  395.  LDX COPY1+1 ;HI BYTE IN .X
  396.  LDA COPY1 ;LO BYTE IN .A
  397.  JMP INTFPA ;FLOAT AND PUSH UNSIGNED INTEGER
  398. ;
  399. ;
  400. END .END
  401.